home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
unixport
/
defsystem.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1986-05-20
|
15KB
|
393 lines
;;;; DEFSYSTEM.LSP
;;;;
;;;; --- System Generation Tool for Kyoto Common Lisp ---
(in-package 'lisp)
(export '(defsystem defkcl defkcn))
(in-package 'compiler)
(in-package 'system)
;;; *KCL-HOME-DIRECTORY*
(defvar *kcl-home-directory* #"../") ; Change!!
(defvar *machine* 'sun3) ; Change!!
(defvar *unixport-directory*
(make-pathname :directory (append (pathname-directory
*kcl-home-directory*)
(list "unixport"))
:name nil :type nil))
(defvar *lsp-directory*
(make-pathname :directory (append (pathname-directory
*kcl-home-directory*)
(list "lsp"))
:name nil :type nil))
(defvar *o-directory*
(make-pathname :directory (append (pathname-directory
*kcl-home-directory*)
(list "o"))
:name nil :type nil))
(defvar *h-directory-file*
(make-pathname :directory (pathname-directory
*kcl-home-directory*)
:name "h" :type nil))
(setq *print-case* :downcase)
(defvar *object-files*
'("main" "alloc" "gbc"
"bitop"
"typespec"
"eval" "macros" "lex" "bds" "frame"
"predicate"
"reference" "assignment" "bind" "let"
"conditional" "block" "iteration" "mapfun"
"prog" "multival" "catch"
"symbol" "cfun" "cmpaux" "package"
"big" "number" "num_pred" "num_comp" "num_arith" "num_sfun"
"num_co" "num_log" "num_rand" "earith"
"character" "char_table"
"sequence" "list" "hash" "array" "string" "structure"
"toplevel"
"file" "read" "backq" "print" "format" "pathname" "unixfsys"
"unixfasl"
"error"
"unixtime" "unixsys" "unixsave" "unixint"))
(defvar *lsp-object-files*
'("defmacro" "evalmacros" "top" "module"))
(defvar *all-libraries*
'("predlib" "setf"
"arraylib" "assert" "defstruct" "describe"
"iolib" "listlib" "mislib" "numlib"
"packlib" "seq" "seqlib" "trace"))
(defun change-file-type (file type)
(make-pathname :directory (pathname-directory file)
:name (pathname-name file)
:type type))
(defun strip-file-type (file) (change-file-type file nil))
(defun search-tree (x tree)
(loop
(cond ((equal x tree) (return t))
((atom tree) (return nil))
((search-tree x (car tree)) (return t))
(t (setq tree (cdr tree))))))
(defmacro defsystem (system-name files &rest body)
(if (atom system-name)
`(make-system ',system-name ',files ',body)
`(apply #'make-system
',(car system-name) ',files ',body
',(cdr system-name))))
(defun make-system (system-name files initial-forms
&key (libraries nil)
(system system-name)
(top-level nil)
(makefile "Makefile"))
(cond ((eq libraries t) (setq libraries *all-libraries*))
(t
(dolist (library libraries)
(unless (member (string library) *all-libraries*
:test #'string-equal)
(error "~S is not a library." library)))
;; Reorder the libraries.
(setq libraries
(mapcan #'(lambda (library)
(if (member library libraries
:test #'string-equal :key #'string)
(list library)
nil))
*all-libraries*))))
(setq files
(mapcar #'(lambda (file)
(if (symbolp file)
(string-downcase (symbol-name file))
file))
files))
(when (symbolp system-name)
(setq system-name (string-downcase (symbol-name system-name))))
(when (symbolp system)
(setq system (string-downcase (symbol-name system))))
(when (symbolp makefile)
(setq makefile (string-downcase (symbol-name makefile))))
(unless (search-tree 'si:init-system initial-forms)
(setq initial-forms (append initial-forms (list '(si:init-system)))))
(when top-level
(setq initial-forms
(append initial-forms
(list `(defun si:top-level () (,top-level))))))
;; Make the sys file.
(with-open-file (stream (format nil "sys_~A.c" system-name)
:direction :output)
(format stream "#include \"include.h\"~%~%")
(format stream "static object fasl_data;~%~%")
(format stream "init_init()~%{~%")
(format stream " enter_mark_origin(&fasl_data);~%")
(format stream " fasl_data = Cnil;~%~%")
(format stream " load(\"~A\");~%"
(namestring (merge-pathnames "export.lsp" *lsp-directory*)))
(dolist (library *lsp-object-files*)
(format stream
" fasl_data = read_fasl_data(\"~A\");~%"
(namestring
(merge-pathnames (change-file-type library "o")
*lsp-directory*)))
(format stream " init_~A(NULL, 0, fasl_data);~%" library))
(format stream " load(\"~A\");~%"
(namestring (merge-pathnames "autoload.lsp" *lsp-directory*)))
(format stream "}~%~%")
(format stream "init_system()~%{~%")
(dolist (library libraries)
(format stream
" printf(\"Initializing ~A... \"); fflush(stdout);~%"
library)
(format stream
" fasl_data = read_fasl_data(\"~A\");~%"
(namestring
(merge-pathnames (change-file-type library
"o")
*lsp-directory*)))
(format stream " init_~A(NULL, 0, fasl_data);~%" library)
(format stream
" printf(\"\\n\"); fflush(stdout);~%"))
(format stream "~%")
(dolist (file files)
(format stream
" printf(\"Initializing ~A... \"); fflush(stdout);~%"
(pathname-name file))
(format stream
" Vpackage->s.s_dbind = user_package;~%")
(format stream
" fasl_data = read_fasl_data(\"~A\");~%"
(namestring
(change-file-type file "o")))
(format stream " init_~A(NULL, 0, fasl_data);~%"
(string-downcase (pathname-name file)))
(format stream
" printf(\"\\n\"); fflush(stdout);~%"))
(format stream
"~% Vpackage->s.s_dbind = user_package;~%")
(format stream "}~%"))
;; Make the init file.
(with-open-file (stream (format nil "init_~A.lsp" system-name)
:direction :output)
(mapcar #'(lambda (package)
(unless (eq package (find-package 'keyword))
(prin1 `(IN-PACKAGE ,(package-name package)) stream)
(terpri stream)))
(list-all-packages))
(prin1 `(IN-PACKAGE ,(package-name *package*)) stream)
(terpri stream)
(prin1 `(PROGN
,@initial-forms
(SI:SAVE-SYSTEM ,(namestring (strip-file-type system)))
(BYE))
stream)
(terpri stream))
;; Make the makefile.
(with-open-file (stream makefile :direction :output)
(format stream "OBJS = ~{~<\\~% ~2,72:;~A~>~^ ~}~%~%"
(mapcar #'(lambda (object-file)
(namestring
(change-file-type (merge-pathnames object-file
*o-directory*)
"o")))
*object-files*))
(format stream "LSPOBJS = ~{~<\\~% ~2,72:;~A~>~^ ~}~%~%"
(mapcar #'(lambda (library)
(namestring
(change-file-type
(merge-pathnames library *lsp-directory*) "o")))
(append *lsp-object-files* libraries)))
(format stream "SYSOBJS = ~{~<\\~% ~2,72:;~A~>~^ ~}~%~%"
(mapcar #'(lambda (file) (namestring (change-file-type file "o")))
files))
(format stream "~A: raw_~A init_~:*~A.lsp~%" system system-name)
(format stream " raw_~A ~A < init_~A.lsp~%~%"
system-name (namestring *unixport-directory*) system-name)
(format stream "raw_~A: $(OBJS) sys_~:*~A.o $(LSPOBJS)~%"
system-name)
(format stream " cc -o raw_~A $(OBJS) sys_~:*~A.o ~
$(LSPOBJS) $(SYSOBJS) -lm~%~%"
system-name)
(format stream "sys_~A.o: sys_~:*~A.c~%" system-name)
(format stream
" cc -c -D~A -DMAXPAGE=16384 -DVSSIZE=2048 -I~A sys_~A.c~%"
(string-upcase (string *machine*))
(namestring *h-directory-file*)
system-name)))
(defvar *cmpnew-directory*
(make-pathname :directory (append (pathname-directory
*kcl-home-directory*)
(list "cmpnew"))
:name nil :type nil))
(defvar *lisp-implementation-version*
(multiple-value-bind (sec min hour date month year)
(get-decoded-time)
(format nil "~A ~D, ~D"
(case month
(1 "January") (2 "Feburary") (3 "March")
(4 "April") (5 "May") (6 "June")
(7 "July") (8 "August") (9 "September")
(10 "October") (11 "November") (12 "December"))
date year)))
(defmacro defkcl (&key (system-name "kcl")
(system (format nil "saved_~a" (string system-name)))
(include-compiler t)
(libraries t)
(makefile "Makefile")
&aux (*package* *package*)
)
(in-package 'system)
(setq *check-time* nil)
`(defsystem (,system-name
:top-level kcl-top-level
:libraries ,libraries
:system ,system
:makefile ,makefile)
,(if include-compiler
(list (merge-pathnames "cmpinline" *cmpnew-directory*)
(merge-pathnames "cmputil" *cmpnew-directory*)
(merge-pathnames "cmptype" *cmpnew-directory*)
(merge-pathnames "cmpbind" *cmpnew-directory*)
(merge-pathnames "cmpblock" *cmpnew-directory*)
(merge-pathnames "cmpcall" *cmpnew-directory*)
(merge-pathnames "cmpcatch" *cmpnew-directory*)
(merge-pathnames "cmpenv" *cmpnew-directory*)
(merge-pathnames "cmpeval" *cmpnew-directory*)
(merge-pathnames "cmpflet" *cmpnew-directory*)
(merge-pathnames "cmpfun" *cmpnew-directory*)
(merge-pathnames "cmpif" *cmpnew-directory*)
(merge-pathnames "cmplabel" *cmpnew-directory*)
(merge-pathnames "cmplam" *cmpnew-directory*)
(merge-pathnames "cmplet" *cmpnew-directory*)
(merge-pathnames "cmploc" *cmpnew-directory*)
;(merge-pathnames "cmpmain" *cmpnew-directory*)
(merge-pathnames "cmpmap" *cmpnew-directory*)
(merge-pathnames "cmpmulti" *cmpnew-directory*)
(merge-pathnames "cmpspecial" *cmpnew-directory*)
(merge-pathnames "cmptag" *cmpnew-directory*)
(merge-pathnames "cmptop" *cmpnew-directory*)
(merge-pathnames "cmpvar" *cmpnew-directory*)
(merge-pathnames "cmpvs" *cmpnew-directory*)
(merge-pathnames "cmpwt" *cmpnew-directory*))
nil)
(allocate 'cons 100)
(allocate 'string 40)
(si:init-system)
(gbc t)
,@(if include-compiler
`((load ,(merge-pathnames "cmpmain.lsp" *cmpnew-directory*))
(gbc t)
(load ,(merge-pathnames "lfun_list.lsp" *cmpnew-directory*))
(gbc t)
(load ,(merge-pathnames "cmpopt.lsp" *cmpnew-directory*))
(gbc t)
(defun compile-file (&rest args
&aux (*print-pretty* nil)
(*package* *package*))
(compiler::init-env)
(apply 'compiler::compile-file1 args))
(defun compile (&rest args &aux (*print-pretty* nil))
(apply 'compiler::compile1 args))
(defun disassemble (&rest args &aux (*print-pretty* nil))
(apply 'compiler::disassemble1 args)))
nil)
(load ,(merge-pathnames "setdoc.lsp" *lsp-directory*))
(setq *old-top-level* (symbol-function 'si:top-level))
(defun kcl-top-level ()
(when (> (si:argc) 1) (setq *system-directory* (si:argv 1)))
,@(if include-compiler
'((when (>= (si:argc) 5)
(let ((si::*quit-tag* (cons nil nil))
(si::*quit-tags* nil)
(si::*break-level* 0)
(si::*break-env* nil)
(si::*ihs-base* 1)
(si::*ihs-top* 1)
(si::*current-ihs* 1)
(*break-enable* nil))
(si:error-set
'(let ((flags (si:argv 4)))
(setq si:*system-directory* (pathname (si:argv 1)))
(compile-file
(si:argv 2)
:output-file (si:argv 3)
:o-file
(case (schar flags 1)
(#\0 nil) (#\1 t) (t (si:argv 5)))
:c-file
(case (schar flags 2)
(#\0 nil) (#\1 t) (t (si:argv 6)))
:h-file
(case (schar flags 3)
(#\0 nil) (#\1 t) (t (si:argv 7)))
:data-file
(case (schar flags 4)
(#\0 nil) (#\1 t) (t (si:argv 8)))
:system-p
(if (char-equal (schar flags 0) #\S) t nil))))
(bye))))
nil)
(format t "KCl (Kyoto Common Lisp) ~A~%"
,*lisp-implementation-version*)
(in-package 'user)
(funcall *old-top-level*))
(defun lisp-implementation-version () ,*lisp-implementation-version*)
(setq *modules* nil)
(gbc t)
(si:reset-gbc-count)
(allocate 'cons 200)
)
)
(defmacro defkcn (&rest r)
`(defkcl :include-compiler nil
:system-name kcn
,@r))